home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / xlibp202.zip / XLARC.PAS < prev    next >
Pascal/Delphi Source File  |  1994-06-18  |  4KB  |  191 lines

  1. {$G+,N-,E-}
  2.  
  3. program XLArc;
  4.  
  5. uses
  6.     XLA2, XMisc2, Dos;
  7.  
  8. var
  9.     f : file;
  10.     p1, p2, p3 : string;
  11.     S : SearchRec;
  12.     n : NameStr;
  13.     d,d1 : DirStr;
  14.     e : ExtStr;
  15.     tmp : boolean;
  16.     nlines, nfiles, i : integer;
  17.     totratio, size,    compsize, origsize : longint;
  18.     mode : word;
  19.     filename : string;
  20.  
  21. procedure ReadFile( var data; s : word; var actual : longint ); far;
  22. var
  23.     amountread : word;
  24. begin
  25.     blockread( f, data, s, amountread );
  26.     actual := amountread;
  27. end;
  28.  
  29. procedure ViewFile( var data; blocksize : word ); far;
  30. var
  31.     i : integer;
  32. begin
  33.     for i := 0 to blocksize - 1 do
  34.         write(TCharArray(data)[i]);
  35. end;
  36.  
  37. procedure WriteFile( var data; blocksize : word ); far;
  38. begin
  39.     blockwrite( f, data, blocksize );
  40. end;
  41.  
  42. procedure Usage;
  43. begin
  44.     writeln('XLArc v2.06 - XLib archiving utility - FREEWARE');
  45. {$IFDEF DPMI}
  46.     write('DPMI Version - ');
  47. {$ENDIF}
  48.     writeln('(C) 1994 Tristan Tarrant');
  49.     writeln('Usage :');
  50.     writeln('XLArc l|x|v|a0|a1 archive.XLA filenames');
  51.     writeln('  Switches ');
  52.     writeln('    l - list files in archive');
  53.     writeln('    v - view files in archive');
  54.     writeln('    x - extract files from archive');
  55.     writeln('    a0 - add files to archive with no compression');
  56.     writeln('    a1 - add files to archive with LZS compression');
  57.     halt(0);
  58. end;
  59.  
  60. begin
  61.     totratio := 0;
  62.     XLAOutProc := WriteFile;
  63.     XLAInProc := ReadFile;
  64.     if ParamCount < 2 then Usage;
  65.     p1 := ParamStr(1);
  66.     p2 := ParamStr(2);
  67.     xstrupcase( p1 );
  68.     xstrupcase( p2 );
  69.     FSplit( p2, d, n, e );
  70.     if e = '' then e := '.XLA';
  71.     p2 := d+n+e;
  72.     if p1 = 'L' then
  73.     begin
  74.         if not XOpenArchive( p2 ) then
  75.         begin
  76.             writeln('Error opening file : ',p2 );
  77.             halt(1);
  78.         end;
  79.         writeln('Contents of archive ',p2 );
  80.         XPrintDir;
  81.         XCloseArchive;
  82.     end else
  83.     if (p1[1] = 'A') and ((p1[2]>='0') or (p1[2]<='1')) then
  84.     begin
  85.         if ParamCount < 3 then Usage;
  86.         if xexists( p2 ) then
  87.         begin
  88.             tmp := XUpdateArchive( p2 );
  89.             if tmp then writeln('Updating archive ',p2);
  90.         end    else
  91.         begin
  92.             tmp := XCreateArchive( p2 );
  93.             if tmp then writeln('Creating archive ',p2);
  94.         end;
  95.         if not tmp then
  96.         begin
  97.             writeln('Cannot create file : ',p2 );
  98.             halt(1);
  99.         end;
  100.         for i := 3 to ParamCount do
  101.         begin
  102.             p3 := ParamStr( i );
  103.             FSplit( p3, d1, n, e );
  104.             FindFirst( p3, Archive, S );
  105.             nfiles := 0;
  106.             while DosError = 0 do
  107.             begin
  108.                 if not xexists( d1+S.Name ) then
  109.                 begin
  110.                     writeln('Cannot open file : ',d1+S.Name );
  111.                     halt(1);
  112.                 end;
  113.                 inc(nfiles);
  114.                 FSplit( S.Name, d, n, e );
  115.                 if e <> '.XLA'  then
  116.                 begin
  117.                     if XLAGetFileInfo(S.Name, origsize, compsize, mode) then
  118.                         writeln('Skipping file ',S.Name,' : already in archive')
  119.                     else
  120.                     begin
  121.                         assign( f, d1+S.Name );
  122.                         reset( f, 1 );
  123.                         case p1[2] of
  124.                             '0' :
  125.                                 begin
  126.                                     write('Storing ', S.Name,'...' );
  127.                                     XLAPut( S.Name, None );
  128.                                 end;
  129.                             '1' :
  130.                                 begin
  131.                                     write('Compressing ', S.Name,'...' );
  132.                                     XLAPut( S.Name, LZS );
  133.                                 end;
  134.                         end;
  135.                         writeln( ratio,'%');
  136.                         totratio := totratio + ratio;
  137.                         close( f );
  138.                     end;
  139.                 end;
  140.                 FindNext(S);
  141.             end;
  142.         end;
  143.         XEndArchive;
  144.         if nfiles >0 then
  145.             writeln('Total ratio = ',totratio div nfiles,'%');
  146.         writeln('Done.');
  147.     end else
  148.     if (p1 = 'X') or (p1 = 'V') then
  149.     begin
  150.         if p1 = 'V' then XLAOutProc := ViewFile;
  151.         if ParamCount <3 then Usage;
  152.         p3 := ParamStr( 3 );
  153.         xstrupcase( p3 );
  154.         if not XOpenArchive( p2 ) then
  155.         begin
  156.             writeln('Could not open file ',p2 );
  157.             halt(1);
  158.         end;
  159.         tmp := XLAFindFirst( p3, filename );
  160.         if not tmp then
  161.         begin
  162.             Writeln('No matches for ',p3,' in archive ',p2 );
  163.             halt(1);
  164.         end;
  165.         while tmp do
  166.         begin
  167.             if not XLAGetFileInfo(filename, origsize, compsize, mode) then
  168.             begin
  169.                 writeln('File ',filename,' does not exist in archive ',p2 );
  170.                 halt(1);
  171.             end;
  172.             writeln('Extracting ',filename,'...');
  173.             if p1 = 'X' then
  174.             begin
  175.                 assign( f, filename);
  176.                 rewrite( f, 1 );
  177.             end;
  178.             if not XLAGet(filename) then
  179.             begin
  180.                 writeln('Could not extract ',filename );
  181.                 halt(1);
  182.             end;
  183.             if p1 = 'X' then
  184.                 close( f );
  185.             tmp := XLAFindNext( filename );
  186.         end;
  187.         XCloseArchive;
  188.         writeln('Done.');
  189.     end else Usage;
  190. end.
  191.